home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / ANIMATE.LZH / OKIGRAFX.PAS < prev    next >
Pascal/Delphi Source File  |  1984-09-17  |  17KB  |  550 lines
  1. program graphicsOnOkidata;
  2. {(c) 1984 by Neil J. Rubenking}
  3. var
  4.   ToggleByte     : byte absolute $40:$17;
  5.   ScrollLock     : byte;
  6.   BigRow, BigCol,        {BigRow & LastRow go from 1 to 55 by threes}
  7.   LastRow, LastCol,      {BigCol & LastCol go from 1 to 561 by forties}
  8.   rows,cols,
  9.   ScreenSeg      : integer;
  10.   up, color      : boolean;
  11.   Key1,Key2      : char;
  12.   ScreenDots     : array[1..42] of array[1..80] of boolean;
  13.   Graffix        : array[1..60] of array[1..640] of byte;
  14.   PosX, PosY     : integer;
  15.   GrafxFile      : text;
  16.   GrafxFileName  : string[14];
  17.   BlankLine      : string[79];
  18. {============================================================================}
  19. function ReadScreen(col,row:byte):char;
  20. var
  21.   LocationCode : integer;
  22.   begin
  23.     LocationCode := (col-1)*2 + (row-1)*160;
  24.     ReadScreen   := chr(Mem[ScreenSeg:LocationCode]);
  25.   end;
  26. {============================================================================}
  27. procedure WriteScrn(col, row: byte; thisChar:char);
  28. var
  29.   LocationCode : integer;
  30. begin
  31.   LocationCode := (col-1)*2 + (row-1)*160;
  32.   Mem[ScreenSeg:locationCode] := ord(ThisChar);
  33. end;
  34. {============================================================================}
  35. procedure blankScreen;
  36. var
  37.   LocationCode : integer;
  38.   col, row     : byte;
  39. begin
  40.   for col := 1 to 80 do
  41.     begin
  42.       for row := 1 to 21 do
  43.         begin
  44.           LocationCode := (col-1)*2 + (row-1)*160;
  45.           Mem[ScreenSeg:locationCode] := 32;      { a blank }
  46.           Mem[ScreenSeg:locationCode+1] := 112;
  47.         end;
  48.     end;
  49. end;
  50. {============================================================================}
  51. {This procedure takes the array "GRAFFIX", which contains the graphics printer
  52. codes, and converts it into an array that can be shown on the screen       }
  53.  
  54. procedure MakeScreen(bigCol,bigRow:integer);
  55. var
  56.   thisByte,
  57.   bits      : byte;
  58.   M, N      : integer;
  59.   thisChar  : char;
  60. begin
  61.   for M := BigCol to BigCol + 79 do
  62.     begin
  63.       for N := BigRow to BigRow + 5 do
  64.         begin
  65.         thisByte := Graffix[N][M];
  66.         for bits := 1 to 7 do
  67.           begin
  68.             if odd(thisbyte) then
  69.                screenDots[(N-BigRow)*7 + bits][M-BigCol+1] := true
  70.             else
  71.                screenDots[(N-BigRow)*7 + bits][M-BigCol+1] := false;
  72.             thisByte := thisByte div 2;
  73.           end;  {for bits}
  74.         end;  {for N := 1 to 6}
  75.       for N := 1 to 21 do
  76.         begin
  77.           if screenDots[2*N-1][M-BigCol+1] then
  78.             begin
  79.               if screenDots[2*N][M-BigCol+1] then
  80.                 begin
  81.                   ThisChar := '█';
  82.                 end
  83.               else ThisChar := '▀'
  84.             end
  85.           else
  86.             begin
  87.               if screenDots[2*N][M-BigCol+1] then
  88.                 begin
  89.                   ThisChar := '▄';
  90.                 end
  91.               else ThisChar := ' ';
  92.             end;
  93.           writeScrn((M-BigCol+1),N,thisChar);
  94.         end;  {for N := 1 to 21}
  95.     end;   {for M}
  96. end;   {procedure}
  97. {============================================================================}
  98. {Converts the current screen into printer graphics codes}
  99. procedure SaveScreen;
  100. var
  101.   dotPos, chNum, doubler : byte;
  102.   N, M                   : integer;
  103. begin
  104.   for M := 1 to 80 do
  105.     begin
  106.       for N := 1 to 21 do
  107.         begin
  108.           case ReadScreen(M,N) of
  109.                '▀': begin
  110.                       ScreenDots[(N*2)-1][M] := true;
  111.                       ScreenDots[(N*2)][M] := false;
  112.                     end;
  113.                '▄': begin
  114.                       ScreenDots[(N*2)-1][M] := false;
  115.                       ScreenDots[(N*2)][M] := true;
  116.                     end;
  117.                ' ': begin
  118.                       ScreenDots[(N*2)-1][M] := false;
  119.                       ScreenDots[(N*2)][M] := false;
  120.                     end;
  121.                '█': begin
  122.                       ScreenDots[(N*2)-1][M] := true;
  123.                       ScreenDots[(N*2)][M] := true;
  124.                     end;
  125.           end;  {case}
  126.         end;  {for N := 1 to 21}
  127.       for N := 1 to 6 do
  128.         begin
  129.           doubler := 1;
  130.           chNum   := 0;
  131.           for dotPos := 1 to 7 do
  132.             begin
  133.               if ScreenDots[7*(N-1)+dotPos][M] then chNum := chNum + doubler;
  134.               doubler := 2*doubler;
  135.             end;
  136.           Graffix[N+BigRow-1][M+BigCol-1] := chNum;
  137.         end;  {for N := 1 to 6}
  138.     end;    {for M := 1 to 80}
  139. end;
  140. {============================================================================}
  141. {Prints to either Printer or file--the printer can qualify as a "text file"  }
  142. procedure doPrint(var which:text);
  143. var
  144.   N, M: byte;
  145. begin
  146.   write(which,chr(3));                {turn on graphics}
  147.   for N := 1 to LastRow + 5 do
  148.     begin
  149.       for M := 1 to LastCol + 79 do
  150.         begin
  151.           write(which,chr(Graffix[N][M]));                 {in order to print}
  152.           if Graffix[N][M] = 3 then write(which,chr(3));  {chr(3) you must  }
  153.         end;   {for M}                                     {print it twice   }
  154.       Write(which, chr(3),chr(14));    {end of graphics line code}
  155.     end;  {for N}
  156.   write(which,chr(3),chr(2));          {turn off graphics}
  157. end;
  158. {============================================================================}
  159. procedure PrintInstructions;
  160. begin
  161.   GotoXY(1,23);
  162.   writeln(BlankLine);
  163.   write(BlankLine);
  164.   gotoXY(1,23);
  165.    Write('F1=set  F2=erase  F3=save/print  F4=retrieve  F7=start over  ');
  166.    WriteLn('F9=blank  F10=end');
  167.    Write('Ctrl-left, right, PgUp, PgDn move "window".  ');
  168.  WriteLn('Ctrl-home & end go to extremes.  ');
  169. end;
  170. {============================================================================}
  171. procedure cursorSet(mode : char);
  172. type
  173.   regpack = record
  174.               ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
  175.             end;
  176.  
  177. var
  178.   recpack:          regpack;             {assign record}
  179.   ah,al,ch,cl,dh:   byte;
  180.  
  181. begin
  182.   ah := 1;
  183.   if color then
  184.     case mode of
  185.       'h': begin ; ch := 0 ; cl := 3 ; end;
  186.       'l': begin ; ch := 4 ; cl := 7 ; end;
  187.       'n': begin ; ch := 6 ; cl := 7 ; end;
  188.     end
  189.   else
  190.       case mode of
  191.       'h': begin ; ch := 0 ; cl := 6 ; end;
  192.       'l': begin ; ch := 7 ; cl := 13 ; end;
  193.       'n': begin ; ch := 12 ; cl := 13 ; end;
  194.     end;
  195.   with recpack do
  196.   begin
  197.     ax := ah shl 8;
  198.     cx := ch shl 8 + cl;
  199.   end;
  200.   intr($10,recpack);                     {call interrupt}
  201. end;
  202. {============================================================================}
  203. procedure AskPrint;
  204. var
  205.   pick : char;
  206.   SaveX,SaveY : byte;
  207. begin
  208.   SaveX := WhereX;
  209.   SaveY := WhereY;
  210.   CursorSet('n');
  211.   window(1,1,80,25);
  212.   gotoXY(1,23);
  213.   writeln(BlankLine);
  214.   write(BlankLine);
  215.   gotoXY(1,23);
  216.   Write('P for Printer, F for File: ');
  217.   repeat
  218.     read(pick);
  219.     write(chr(8));
  220.     until UpCase(pick) in ['P','F'];
  221.   if UpCase(pick) = 'P' then DoPrint(Lst)
  222.   else
  223.     begin
  224.       gotoXY(1,23);
  225.       write('Enter FileName--no  extension.');
  226.       read(GrafxFileName);
  227.       GrafxFileName :=  GrafxFileName + '.OKI';
  228.       Assign(GrafxFile, GrafxFileName);
  229.       rewrite(GrafxFile);
  230.       DoPrint(GrafxFile);
  231.       close(GrafxFile);
  232.     end;
  233.   PrintInstructions;
  234.   window(1,1,80,22);
  235.   GotoXY(SaveX,SaveY);
  236.   if up then CursorSet('h') else CursorSet('l');
  237. end;
  238. {============================================================================}
  239. procedure initialize;
  240. begin
  241.   IF (Mem[0000:1040] AND 48) <> 48 THEN
  242.     begin
  243.       ScreenSeg := $B800;
  244.       color     := true;
  245.     end
  246.    ELSE
  247.      begin
  248.        ScreenSeg := $B000;
  249.        color     := false;
  250.      end;
  251.    window(1,1,80,25);
  252.    textcolor(black);
  253.    textBackground(white);
  254.    GotoXY(1,23);
  255.    Write('I N I T I A L I Z I N G . . . .');
  256.    BlankScreen;
  257.    for rows := 1 to 60 do
  258.      for cols := 1 to 640 do
  259.        Graffix[rows][cols] := 0;
  260.    printInstructions;
  261.    window(1,1,80,22);
  262.    BlankLine := '                                       ';
  263.    BlankLine := BlankLine + BlankLine;
  264.    gotoXY(1,1);
  265.    up := true;
  266.    BigRow := 1;
  267.    LastRow := 1;
  268.    BigCol := 1;
  269.    LastCol := 1;
  270.    CursorSet('h');
  271. end;
  272. {============================================================================}
  273. procedure DoRetrieve(var ThisFile : text);
  274. var
  275.   This, Next, ThrowOut : char;
  276.   row         : byte;
  277.   MaxCol, col : integer;
  278. begin
  279.   initialize;
  280.   row := 1;
  281.   col := 1;
  282.   this := chr(0);
  283.   next := chr(0);
  284.   reset(ThisFile);
  285.   read(ThisFile,ThrowOut);
  286.   while not EOF(ThisFile) do
  287.     begin
  288.       read(ThisFile,this);
  289.       if this = chr(3) then
  290.         begin
  291.           read(ThisFile,next);
  292.           case ord(Next) of
  293.               3: begin
  294.                    Graffix[row][col] := ord(this);
  295.                    col := col + 1;
  296.                  end;
  297.              14: begin
  298.                    row := row + 1;
  299.                    col := 1;
  300.                  end;
  301.               2: ;
  302.           else
  303.             Graffix[row][col] := ord(this);
  304.             col := col + 1;
  305.             Graffix[row][col] := ord(next);
  306.             col := col + 1;
  307.           end;  {case}
  308.         end    {if}
  309.       else
  310.         begin
  311.           Graffix[row][col] := ord(this);
  312.           col := col + 1;
  313.         end;
  314.       if col > MaxCol then MaxCol := col;
  315.     end;  {while}
  316.   LastRow := row - 5;
  317.   LastCol := MaxCol - 79;
  318.   close(Thisfile);
  319.   MakeScreen(BigCol,BigRow);
  320.   window(1,1,80,25);
  321.   PrintInstructions;
  322.   window(1,1,80,22);
  323.   gotoXY(1,1);
  324.   up := true;
  325.   CursorSet('h');
  326. end;
  327. {============================================================================}
  328. procedure AskRetrieve;
  329. begin
  330.   CursorSet('n');
  331.   window(1,1,80,25);
  332.   gotoXY(1,23);
  333.   writeln(BlankLine);
  334.   write(BlankLine);
  335.   gotoXY(1,23);
  336.   WriteLn('Enter FileName--no extension: ');
  337.   read(GrafxFileName);
  338.   GrafxFileName := GrafxFileName + '.OKI';
  339.   Assign(GrafxFile,GrafxFileName);
  340.   DoRetrieve(GrafxFile);
  341. end;
  342. {============================================================================}
  343. procedure DoInsert;   {Not yet implemented}
  344. begin
  345. end;
  346. {============================================================================}
  347. procedure TakeOrders;
  348.      {--------------------------------------}
  349.      procedure GoUp;
  350.      begin
  351.        if not up then
  352.          begin
  353.            up := true;
  354.            CursorSet('h');
  355.          end
  356.        else
  357.          if WhereY > 1 then
  358.            begin
  359.              up := false;
  360.              CursorSet('l');
  361.              GotoXY(WhereX,WhereY-1);
  362.            end
  363.          else
  364.            begin
  365.              up := false;
  366.              CursorSet('l');
  367.              GotoXY(WhereX,21);
  368.            end;
  369.      end;
  370.      {--------------------------------------}
  371.      procedure GoDown;
  372.      begin
  373.        if  up then
  374.          begin
  375.            up := false;
  376.            CursorSet('l');
  377.          end
  378.        else
  379.          if WhereY < 21 then
  380.            begin
  381.              up := true;
  382.              CursorSet('h');
  383.              GotoXY(WhereX,WhereY+1);
  384.            end
  385.          else
  386.            begin
  387.              up := true;
  388.              CursorSet('h');
  389.              GotoXY(WhereX,1);
  390.            end;
  391.      end;
  392.      {--------------------------------------}
  393.      procedure GoLeft;
  394.      begin
  395.        if WhereX > 1 then gotoXY(WhereX-1,WhereY) else gotoXY(80,WhereY);
  396.      end;
  397.      {--------------------------------------}
  398.      procedure GoRight;
  399.      begin
  400.        if WhereX < 80 then GotoXY(WhereX+1,WhereY) else gotoXY(1,WhereY);
  401.      end;
  402.      {--------------------------------------}
  403.      procedure WriteADot;
  404.      begin
  405.        if up then
  406.          begin
  407.            if ReadScreen(WhereX,WhereY) = '▄' then writeScrn(WhereX,WhereY,'█')
  408.               else writeScrn(WhereX,WhereY,'▀'); {if low then whl else high}
  409.          end
  410.        else
  411.          begin
  412.            if ReadScreen(WhereX,WhereY) = '▀' then writeScrn(WhereX,WhereY,'█')
  413.              else writeScrn(WhereX,WhereY,'▄');{if high then whl else low}
  414.          end;
  415.      end;
  416.      {--------------------------------------}
  417.      procedure EraseADot;
  418.      begin
  419.      if up then
  420.        begin
  421.          if ReadScreen(WhereX,WhereY) = '█' then writeScrn(WhereX,WhereY,'▄')
  422.            else writeScrn(WhereX,WhereY,' ');
  423.        end                        {if whl then low else space}
  424.      else
  425.        begin
  426.          if ReadScreen(WhereX,WhereY) = '█' then writeScrn(WhereX,WhereY,'▀')
  427.            else writeScrn(WhereX,WhereY,' ');
  428.        end;                       {if whl then high else space}
  429.      end;
  430.      {--------------------------------------}
  431.  
  432. begin
  433.   repeat until keypressed;
  434.   read(Kbd,Key1);
  435.   if Key1 = chr(27) then
  436.     begin
  437.       read(Kbd,Key2);
  438.       case Key2 of
  439.       {home}   'G': begin
  440.                       if ScrollLock = 16 then WriteADot;
  441.                       GoUp;
  442.                       GoLeft;
  443.                     end;
  444.       {up}     'H': begin
  445.                       if ScrollLock = 16 then WriteADot;
  446.                       GoUp;
  447.                     end;
  448.       {PgUp}   'I': begin
  449.                       if ScrollLock = 16 then WriteADot;
  450.                       GoUp;
  451.                       GoRight;
  452.                     end;
  453.       {left}   'K': begin
  454.                       if ScrollLock = 16 then WriteADot;
  455.                       GoLeft;
  456.                     end;
  457.       {right}  'M': begin
  458.                       if ScrollLock = 16 then WriteADot;
  459.                       GoRight;
  460.                     end;
  461.       {end}    'O': begin
  462.                       if ScrollLock = 16 then WriteADot;
  463.                       GoDown;
  464.                       GoLeft;
  465.                     end;
  466.       {down}   'P': begin
  467.                       if ScrollLock = 16 then WriteADot;
  468.                       GoDown;
  469.                     end;
  470.       {PgDn}   'Q': begin
  471.                       if ScrollLock = 16 then WriteADot;
  472.                       GoDown;
  473.                       GoRight;
  474.                     end;
  475.    {Ctrl-home} 'w': begin           {goes to top right of "Big Picture"}
  476.                       SaveScreen;
  477.                       BigRow := 1;
  478.                       BigCol := 1;
  479.                       MakeScreen(BigCol,BigRow);
  480.                       GotoXY(1,1);
  481.                       up := true;
  482.                       CursorSet('h');
  483.                     end;   {ctrl-home}
  484.    {Ctrl-PgDn} 'v': if BigRow < 55 then  {moves "window" down ½ screen}
  485.                       begin
  486.                         SaveScreen;
  487.                         BlankScreen;
  488.                         BigRow := BigRow + 3;
  489.                         if LastRow < BigRow then LastRow := BigRow;
  490.                         MakeScreen(BigCol,BigRow);
  491.                     end;   {ctrl-pgUp}
  492.    {Ctrl-left} 's': if BigCol > 40 then   {moves "window" to left ½ screen}
  493.                       begin
  494.                         SaveScreen;
  495.                         BlankScreen;
  496.                         BigCol := BigCol - 40;
  497.                         MakeScreen(BigCol,BigRow);
  498.                       end;
  499.    {Ctrl-right}'t': if BigCol < 561 then   {moves "window" to right ½ screen}
  500.                       begin
  501.                         SaveScreen;
  502.                         BlankScreen;
  503.                         BigCol := BigCol + 40;
  504.                         if LastCol < BigCol then LastCol := BigCol;
  505.                         MakeScreen(BigCol,BigRow);
  506.                       end;
  507.    {Ctrl-end}  'u': begin          {goes to bottom right of "big picture"}
  508.                       SaveScreen;
  509.                       BigRow := LastRow;
  510.                       BigCol := LastCol;
  511.                       MakeScreen(BigCol,BigRow);
  512.                       GotoXY(80,21);
  513.                       up := false;
  514.                       CursorSet('l');
  515.                     end;     {ctrl-end}
  516.     {Ctrl-PgUp}'ä': if BigRow > 3 then  {moves "window" up ½ screen}
  517.                       begin
  518.                         SaveScreen;
  519.                         BlankScreen;
  520.                         BigRow := BigRow - 3;
  521.                         MakeScreen(BigCol,BigRow);
  522.                     end;     {ctrl-PgDn}
  523.     {F1}       ';': WriteADot;
  524.     {F2}       '<': EraseADot;
  525.     {F3}       '=': begin
  526.                       SaveScreen;
  527.                       AskPrint;
  528.                     end;
  529.     {F4}       '>': AskRetrieve;
  530.     {F5}       '?':;
  531.     {F6}       '@':;
  532.     {F7}       'A':initialize;
  533.     {F8}       'B':;
  534.     {F9}       'C': BlankScreen;
  535.    {Ins}       'R': DoInsert;
  536.       end;  {case statement}
  537.    end;   {"if Key1 = chr(27)"}
  538. end;  {procedure}
  539. {============================================================================}
  540. begin
  541.   initialize;
  542.   repeat
  543.     ScrollLock := ToggleByte and 16;
  544.     TakeOrders;
  545.   until Key2 = 'D';
  546.   window(1,1,80,25);
  547.   ClrScr;
  548.   gotoXY(1,24);
  549.   CursorSet('n');
  550. end.